home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue42 / construc / DRBOBNEW.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-01-11  |  9.6 KB  |  377 lines
  1. unit DrBobNEW;
  2. {.$R+}
  3. {$DEFINE DEBUG}
  4. interface
  5. uses
  6.   Classes, {$IFDEF DEBUG}StdCtrls,{$ENDIF} ScktComp;
  7.  
  8. const
  9.   MaxGroups = 256;
  10.  
  11. type
  12.   TBNNTP = class(TComponent)
  13.   public
  14.     constructor Create(AOwner: TComponent); override;
  15.     destructor Destroy; override;
  16.   public
  17.   {$IFDEF DEBUG}
  18.     StatusMemo: TMemo; { pointer to Form's Memo }
  19.   {$ENDIF}
  20.     procedure Connect;
  21.     procedure JoinNewsGroup(const NewsGroup: String);
  22.     procedure ReadArticle(ArticleNr: Integer);
  23.     procedure PostArticle(const NewArticle: String);
  24.     procedure Disconnect;
  25.  
  26.   protected
  27.     _Socket: TClientSocket;
  28.     procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  29.     procedure SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  30.     procedure Wait;
  31.  
  32.   private
  33.     fNewsServer: String;
  34.   published
  35.     property NewsServer: String read fNewsServer write fNewsServer;
  36.  
  37.   private
  38.     fReadOnly: Boolean;
  39.     fNewArticle: String;
  40.   published
  41.     property ReadOnly: Boolean read fReadOnly;
  42.  
  43.   private // newgroups
  44.     fNumGroups: Integer;
  45.     fNewsGroups: Array[0..MaxGroups-1] of String;
  46.     function GetNewsGroup(Index: Integer): String;
  47.   public
  48.     property NewsGroups: Integer read fNumGroups;
  49.     property NewsGroup[Index: Integer]: String read GetNewsGroup;
  50.  
  51.   private // articles
  52.     fFirstArticle,fLastArticle: Integer;
  53.     fArticles: Array of String;
  54.     function GetArticle(Index: Integer): String;
  55.   public
  56.     property FirstArticle: Integer read fFirstArticle;
  57.     property LastArticle: Integer read fLastArticle;
  58.     property Article[Index: Integer]: String read GetArticle;
  59.  
  60.   private // internal
  61.     WinSocket: TCustomWinSocket;
  62.     Command: Integer;
  63.     ArtNr: Integer;
  64.     Status: String; { also NewsgroupName }
  65.   {$IFDEF DEBUG}
  66.     Indent: Integer;
  67.   {$ENDIF}
  68.   end;
  69.  
  70.   procedure Register;
  71.  
  72. implementation
  73. uses
  74.   SysUtils, Forms;
  75.  
  76. const
  77.   CmdStart =   0;
  78.   CmdList  =   1; { list newsgroups }
  79.   CmdJoin  =   2; { join newsgroup }
  80.   CmdMess  =   3; { read article # }
  81.   CmdPost  =   4; { post article }
  82.   CmdPost2 =   5; { post content }
  83.   CmdHelp  =   7; { summary commands }
  84.   CmdDone  =  42; { signals ready }
  85.   CmdQuit  = 666;
  86.  
  87. const
  88.   NNTP = 119;
  89.  
  90. const
  91.   CRLF = #13#10;
  92.  
  93. {$IFDEF DEBUG}
  94.   function Space(X: Integer): String;
  95.   begin
  96.     Result := '';
  97.     while X > 0 do
  98.     begin
  99.       Result := Result + ' ';
  100.       Dec(X)
  101.     end
  102.   end {Space};
  103. {$ENDIF}
  104.  
  105. constructor TBNNTP.Create(AOwner: TComponent);
  106. begin
  107.   inherited Create(AOwner);
  108.   _Socket := TClientSocket.Create(Self);
  109.   _Socket.Port := NNTP;
  110.   _Socket.OnRead := SocketRead;
  111.   _Socket.OnWrite := SocketWrite;
  112.   fReadOnly := True;
  113. {$IFDEF DEBUG}
  114.   Indent := 0;
  115.   StatusMemo := nil;
  116. {$ENDIF}
  117.   WinSocket := nil
  118. end {Create};
  119.  
  120. destructor TBNNTP.Destroy;
  121. begin
  122.   _Socket.OnRead := nil;
  123.   _Socket.OnWrite := nil;
  124. //if Assigned(WinSocket) and (Command <> CmdQuit) then
  125. //  WinSocket.SendText('QUIT'+ CRLF);
  126.   WinSocket := nil;
  127.   _Socket.Free;
  128.   _Socket := nil;
  129. {$IFDEF DEBUG}
  130.   StatusMemo := nil;
  131. {$ENDIF}
  132.   inherited Destroy
  133. end {Destroy};
  134.  
  135.  
  136. function TBNNTP.GetNewsGroup(Index: Integer): String;
  137. begin
  138.   if Index < MaxGroups then Result := fNewsGroups[Index]
  139.                        else Result := ''
  140. end {GetNewsGroup};
  141.  
  142. function TBNNTP.GetArticle(Index: Integer): String;
  143. begin
  144.   if (Index >= fFirstArticle) and
  145.     ((Index-fFirstArticle) < Length(fArticles)) then
  146.     Result := fArticles[Index-fFirstArticle]
  147.   else Result := ''
  148. end {GetArticle};
  149.  
  150.  
  151. procedure TBNNTP.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  152. var
  153.   i,j: Integer;
  154.   EOD: Boolean; { end-of-data }
  155.   ResponseCode: Integer;
  156. begin
  157. {$IFDEF DEBUG}
  158.   if Assigned(StatusMemo) then
  159.     StatusMemo.Lines.Add(Space(Indent)+'SocketRead');
  160. {$ENDIF}
  161.   WinSocket := Socket; { talk back? }
  162.   Status := Socket.ReceiveText;
  163.   ResponseCode := StrToInt(Copy(Status,1,Pos(' ',Status)-1));
  164.  
  165.   while (Length(Status) > 0) and (Status[Length(Status)] in [#10,#13]) do
  166.     Delete(Status,Length(Status),1);
  167.   EOD := Pos(CRLF+'.',Copy(Status,Length(Status)-4,5)) > 0;
  168.   // Pos(CRLF+'.',Status) > (Length(Status)-4);
  169. {$IFDEF DEBUG}
  170.   if Assigned(StatusMemo) then
  171.   begin
  172.     if Command <> CmdMess then
  173.       StatusMemo.Lines.Add(Space(Indent)+Status)
  174.     else StatusMemo.Lines.Add(Space(Indent)+Copy(Status,1,Pos(#13,Status)-1));
  175.     StatusMemo.Update; { force repaint }
  176.   end
  177.   else
  178.     if IsConsole then writeln(Status);
  179. {$ENDIF}
  180.   case Command of
  181.     CmdStart:
  182.       begin
  183.         fReadOnly := not (ResponseCode = 200);
  184.         Command := CmdList; { get newsgroup list }
  185.         ArtNr := 0
  186.       end;
  187.      CmdPost:
  188.        begin
  189.          if ResponseCode = 340 then Command := CmdPost2
  190.                                else Command := CmdDone
  191.        end;
  192.      CmdPost2:
  193.        begin
  194.          Command := CmdDone
  195.        end;
  196.      CmdHelp:
  197.        begin
  198.        { receive summary of commands }
  199.          Command := CmdDone;
  200.        end;
  201.      CmdList:
  202.        begin
  203.          fNumGroups := -1;
  204.          while Length(Status) > 1 do
  205.          begin
  206.            Inc(fNumGroups);
  207.            i := Pos(#13,Status);
  208.            j := Pos(#10,Status);
  209.            if (i = 0) and (j = 0) then i := Length(Status)
  210.            else
  211.              if j > i then i := j;
  212.            j := 1;
  213.            while (j < i) and (Status[j] > #32) do Inc(j);
  214.            if fNumGroups > 0 then
  215.            begin
  216.              fNewsGroups[fNumGroups-1] := Copy(Status,1,j-1);
  217.              if fNewsGroups[fNumGroups-1] = '' then
  218.                Dec(fNumGroups)
  219.            end;
  220.            Delete(Status,1,i);
  221.            while (Length(Status) > 0) and (Status[1] in [#10,#13]) do Delete(Status,1,1)
  222.          end;
  223.          if (Status = '.') or EOD then Command := CmdDone
  224.                                   else ArtNr := -1 { continue }
  225.        end;
  226.      CmdJoin:
  227.        begin
  228.          i := Pos(' ',Status);
  229.          Delete(Status,1,i); { status code }
  230.          i := Pos(' ',Status);
  231.          Delete(Status,1,i); { number of articles }
  232.          i := Pos(' ',Status);
  233.          try
  234.            fFirstArticle := StrToInt(Copy(Status,1,i-1))
  235.          except
  236.            fFirstArticle := 1
  237.          end;
  238.          Delete(Status,1,i); { last article }
  239.          i := Pos(' ',Status);
  240.          try
  241.            fLastArticle := StrToInt(Copy(Status,1,i-1))
  242.          except
  243.            fLastArticle := 1
  244.          end;
  245.          fArticles := nil;
  246.          if fLastArticle >= fFirstArticle then
  247.            SetLength(fArticles,fLastArticle-fFirstArticle+1); // allocate
  248.        {$IFDEF DEBUG}
  249.          if Assigned(StatusMemo) then
  250.            StatusMemo.Lines.Add(Space(Indent)+IntToStr(fFirstArticle)+' to '+IntToStr(fLastArticle))
  251.          else
  252.            if IsConsole then writeln(fFirstArticle,' to ',fLastArticle);
  253.        {$ENDIF}
  254.          Command := CmdDone
  255.        end;
  256.      CmdMess:
  257.        begin
  258.          if ArtNr < 0 then { remaining part of article }
  259.            fArticles[-ArtNr-fFirstArticle] := fArticles[-ArtNr-fFirstArticle] + Status
  260.          else
  261.          begin
  262.            i := Pos(#13,Status);
  263.            if i > 0 then
  264.            begin
  265.              Delete(Status,1,i);
  266.              while (Length(Status) > 0) and (Status[1] in [#10,#13]) do Delete(Status,1,1)
  267.            end;
  268.            fArticles[ArtNr-fFirstArticle] := Status
  269.          end;
  270.          if EOD then Command := CmdDone
  271.          else
  272.            ArtNr := -abs(ArtNr) { negative }
  273.        end;
  274.      CmdQuit: Command := CmdDone
  275.   end;
  276.   if Command <> CmdDone then SocketWrite(Sender, Socket)
  277. end {SocketRead};
  278.  
  279. procedure TBNNTP.SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  280. var
  281.   Send: String;
  282. begin
  283.   Send := '';
  284.   case Command of
  285.     CmdList: if ArtNr >= 0 then Send := 'LIST';
  286.     CmdJoin: Send := 'GROUP ' + Status;
  287.     CmdMess: if ArtNr > 0 then
  288.                Send := 'ARTICLE ' + IntToStr(ArtNr);
  289.     CmdPost: Send := 'POST';
  290.     CmdPost2:Send := fNewArticle;
  291.     CmdHelp: Send := 'HELP';
  292.     CmdQuit: Send := 'QUIT'
  293.   end;
  294. {$IFDEF DEBUG}
  295.   if Assigned(StatusMemo) then
  296.     StatusMemo.Lines.Add(Space(Indent)+'> '+Send)
  297.   else
  298.     if IsConsole then writeln('> '+Send);
  299. {$ENDIF}
  300.   Socket.SendText(Send + CRLF)
  301. end {SocketWrite};
  302.  
  303. procedure TBNNTP.Wait;
  304. begin
  305. {$IFDEF DEBUG}
  306.   Inc(Indent);
  307.   if Assigned(StatusMemo) then
  308.     StatusMemo.Lines.Add(Space(Indent)+'Waiting...')
  309.   else
  310.     if IsConsole then writeln('Waiting...');
  311.   Inc(Indent);
  312. {$ENDIF}
  313.   repeat
  314.     Application.ProcessMessages
  315.   until Command = CmdDone;
  316. {$IFDEF DEBUG}
  317.   Dec(Indent);
  318.   if Assigned(StatusMemo) then
  319.     StatusMemo.Lines.Add(Space(Indent)+'Done.')
  320.   else
  321.     if IsConsole then writeln('Done.');
  322.   Dec(Indent);
  323. {$ENDIF}
  324. end;
  325.  
  326. procedure TBNNTP.Connect;
  327. begin
  328.   Command := CmdStart;
  329.   _Socket.Active := False;
  330.   _Socket.Host := fNewsServer;
  331.   _Socket.Open;
  332.   Wait
  333. end {Connect};
  334.  
  335. procedure TBNNTP.Disconnect;
  336. begin
  337.   Command := CmdQuit;
  338.   SocketWrite(Self,WinSocket);
  339.   Wait
  340. end {Connect};
  341.  
  342. procedure TBNNTP.JoinNewsGroup(const NewsGroup: String);
  343. begin
  344.   Status := NewsGroup;
  345.   Command := CmdJoin;
  346.   SocketWrite(Self,WinSocket);
  347.   Wait
  348. end {JoinNewsGroup};
  349.  
  350. procedure TBNNTP.ReadArticle(ArticleNr: Integer);
  351. begin
  352.   ArtNr := ArticleNr;
  353.   Command := CmdMess;
  354.   SocketWrite(Self,WinSocket);
  355.   Wait
  356. end {ReadArticle};
  357.  
  358. procedure TBNNTP.PostArticle(const NewArticle: String);
  359. begin
  360.   if not fReadOnly then
  361.   begin
  362.     fNewArticle := NewArticle;
  363.     Command := CmdPost;
  364.     SocketWrite(Self,WinSocket);
  365.     Wait
  366.   end
  367. end {PostArticle};
  368.  
  369.  
  370. procedure Register;
  371. begin
  372.   RegisterComponents('Dr.Bob',[TBNNTP])
  373. end;
  374.  
  375. end.
  376.  
  377.